home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / class.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  41.7 KB  |  1,521 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    class.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include <string.h>
  35.  
  36. #include "class.h"
  37.  
  38. #include "alloc.h"
  39. #include "apply.h"
  40. #include "array.h"
  41. #include "boolean.h"
  42. #include "bytestring.h"
  43. #include "classprec.h"
  44. #include "deque.h"
  45. #include "env.h"
  46. #include "error.h"
  47. #include "eval.h"
  48. #include "function.h"
  49. #include "globaldefs.h"
  50. #include "keyword.h"
  51. #include "list.h"
  52. #include "number.h"
  53. #include "prim.h"
  54. #include "slot.h"
  55. #include "symbol.h"
  56. #include "table.h"
  57. #include "values.h"
  58. #include "vector.h"
  59.  
  60. extern struct binding *symbol_binding (Object sym);
  61.  
  62. static Object class_slots_class;
  63.  
  64. /* primitives */
  65. static Object make_limited_int_type (Object args);
  66. static Object make_union_type (Object typelist);
  67. static Object class_precedence_list (Object class);
  68.  
  69. static struct primitive class_prims[] =
  70. {
  71.     {"%make", prim_2, make},
  72.     {"%instance?", prim_2, instance_p},
  73.     {"%subtype?", prim_2, subtype_p},
  74.     {"%object-class", prim_1, objectclass},
  75.     {"%singleton", prim_1, singleton},
  76.     {"%direct-superclasses", prim_1, direct_superclasses},
  77.     {"%direct-subclasses", prim_1, direct_subclasses},
  78.     {"%seal", prim_1, seal},
  79.     {"%limited-integer", prim_1, make_limited_int_type},
  80.     {"%union-type", prim_1, make_union_type},
  81.     {"%all-superclasses", prim_1, class_precedence_list}
  82. };
  83.  
  84. /* local function prototypes */
  85.  
  86. static Object make_builtin_class (char *name, Object superclasses);
  87. static Object add_slot_descriptor_names (Object sd_list, Object *sg_names_ptr);
  88. static Object append_slot_descriptors (Object sd_list,
  89.                        Object **new_sd_list_insert_ptr,
  90.                        Object *sg_names_ptr);
  91. static Object append_one_slot_descriptor (Object sd,
  92.                       Object **new_sd_list_insert_ptr,
  93.                       Object *sg_names_ptr);
  94. static void make_getters_setters (Object class, Object slots);
  95. static Object make_getter_method (Object getter_name,
  96.                   Object class,
  97.                   int slot_num);
  98. static Object make_setter_method (Object slot,
  99.                   Object class,
  100.                   int slot_num);
  101. Object initialize_slots (Object descriptors, Object initializers);
  102. static Object pair_list_reverse (Object lst);
  103. static void replace_slotd_init (Object init_slotds, Object keyword,
  104.                 Object init);
  105. static void initialize_slotds (Object class);
  106. static void eval_slotds (Object slotds);
  107.  
  108. /* function definitions */
  109.  
  110. void
  111. init_class_prims (void)
  112. {
  113.     int num;
  114.  
  115.     num = sizeof (class_prims) / sizeof (struct primitive);
  116.  
  117.     init_prims (num, class_prims);
  118. }
  119.  
  120. void
  121. init_class_hierarchy (void)
  122. {
  123.     object_class = make_builtin_class ("<object>", make_empty_list ());
  124.  
  125.     /* fix up the binding for object_class so that it is correct */
  126.     {
  127.     struct binding *binding;
  128.  
  129.     binding = symbol_binding (CLASSNAME (object_class));
  130.     binding->type = object_class;
  131.     }
  132.     boolean_class = make_builtin_class ("<boolean>", object_class);
  133.  
  134.     /* Numeric classes */
  135.     number_class = make_builtin_class ("<number>", object_class);
  136.     complex_class = make_builtin_class ("<complex>", number_class);
  137.     real_class = make_builtin_class ("<real>", complex_class);
  138.     rational_class = make_builtin_class ("<rational>", real_class);
  139.     integer_class = make_builtin_class ("<integer>", rational_class);
  140.  
  141. #ifdef BIG_INTEGERS
  142.     small_integer_class = make_builtin_class ("<small-integer>", integer_class);    /* <pcb> */
  143.     big_integer_class = make_builtin_class ("<big-integer>", integer_class);    /* <pcb> */
  144. #endif
  145.  
  146.     ratio_class = make_builtin_class ("<ratio>", rational_class);
  147.     float_class = make_builtin_class ("<float>", real_class);
  148.     single_float_class = make_builtin_class ("<single-float>", float_class);
  149.     double_float_class = make_builtin_class ("<double-float>", float_class);
  150.  
  151.     /* Collection classes */
  152.     collection_class = make_builtin_class ("<collection>", object_class);
  153.     explicit_key_collection_class =
  154.     make_builtin_class ("<explicit-key-collection>",
  155.                 collection_class);
  156.     stretchy_collection_class =
  157.     make_builtin_class ("<stretchy-collection>", collection_class);
  158.     mutable_collection_class =
  159.     make_builtin_class ("<mutable-collection>", collection_class);
  160.     sequence_class =
  161.     make_builtin_class ("<sequence>", collection_class);
  162.     mutable_explicit_key_collection_class =
  163.     make_builtin_class ("<mutable-explicit-key-collection>",
  164.                 listem (explicit_key_collection_class,
  165.                     mutable_collection_class,
  166.                     NULL));
  167.     mutable_sequence_class =
  168.     make_builtin_class ("<mutable-sequence>",
  169.                 listem (mutable_collection_class,
  170.                     sequence_class,
  171.                     NULL));
  172.     table_class =
  173.     make_builtin_class ("<table>",
  174.                 listem (mutable_explicit_key_collection_class,
  175.                     stretchy_collection_class,
  176.                     NULL));
  177.  
  178.     object_table_class =
  179.     make_builtin_class ("<object-table>", table_class);
  180.  
  181.     deque_class =
  182.     make_builtin_class ("<deque>",
  183.                 listem (mutable_sequence_class,
  184.                     stretchy_collection_class,
  185.                     NULL));
  186.     array_class =
  187.     make_builtin_class ("<array>", mutable_sequence_class);
  188.     list_class = make_builtin_class ("<list>", mutable_sequence_class);
  189.     empty_list_class = make_builtin_class ("<empty-list>", list_class);
  190.     pair_class = make_builtin_class ("<pair>", list_class);
  191.     string_class = make_builtin_class ("<string>", mutable_sequence_class);
  192.     vector_class = make_builtin_class ("<vector>", array_class);
  193.     byte_string_class =
  194.     make_builtin_class ("<byte-string>",
  195.                 listem (string_class,
  196.                     vector_class,
  197.                     NULL));
  198.     unicode_string_class =
  199.     make_builtin_class ("<unicode-string>",
  200.                 listem (string_class,
  201.                     vector_class,
  202.                     NULL));
  203.     simple_object_vector_class =
  204.     make_builtin_class ("<simple-object-vector>", vector_class);
  205.  
  206.     /* Condition classes */
  207.     condition_class = make_builtin_class ("<condition>", object_class);
  208.     serious_condition_class = make_builtin_class ("<serious-condition>",
  209.                           condition_class);
  210.     warning_class = make_builtin_class ("<warning>", condition_class);
  211.     simple_warning_class = make_builtin_class ("<simple-warning>",
  212.                            warning_class);
  213.     restart_class = make_builtin_class ("<restart>", condition_class);
  214.     simple_restart_class = make_builtin_class ("<simple-restart>",
  215.                            restart_class);
  216.     abort_class = make_builtin_class ("<abort>", restart_class);
  217.     error_class = make_builtin_class ("<error>", condition_class);
  218.     simple_error_class = make_builtin_class ("<simple-error>",
  219.                          error_class);
  220.     type_error_class = make_builtin_class ("<type-error>",
  221.                        error_class);
  222.     sealed_object_error_class =
  223.     make_builtin_class ("<sealed-object-error>", error_class);
  224.     symbol_class = make_builtin_class ("<variable-name>", object_class);
  225.     keyword_class = make_builtin_class ("<symbol>", object_class);
  226.     character_class = make_builtin_class ("<character>", object_class);
  227.     function_class = make_builtin_class ("<function>", object_class);
  228.     primitive_class = make_builtin_class ("<primitive>", function_class);
  229.     generic_function_class =
  230.     make_builtin_class ("<generic-function>", function_class);
  231.     method_class = make_builtin_class ("<method>", function_class);
  232.     exit_function_class =
  233.     make_builtin_class ("<exit-function>", function_class);
  234.     type_class = make_builtin_class ("<type>", object_class);
  235.     singleton_class = make_builtin_class ("<singleton>", type_class);
  236.     class_class = make_builtin_class ("<class>", type_class);
  237.     stream_class = make_builtin_class ("<stream>", object_class);
  238.     table_entry_class = make_builtin_class ("<table-entry>", object_class);
  239.     deque_entry_class = make_builtin_class ("<deque-entry>", object_class);
  240.  
  241.     class_slots_class =
  242.     make_builtin_class ("<class-slots-class>", object_class);
  243.  
  244.     foreign_pointer_class =
  245.     make_builtin_class ("<foreign-pointer>", object_class);        /* <pcb> */
  246.  
  247.     seal (integer_class);
  248.     seal (ratio_class);
  249.     seal (rational_class);
  250.     seal (single_float_class);
  251.     seal (double_float_class);
  252.     seal (float_class);
  253.     seal (real_class);
  254.     seal (empty_list_class);
  255.     seal (pair_class);
  256.     seal (list_class);
  257.     seal (byte_string_class);
  258.     seal (unicode_string_class);
  259.     seal (simple_object_vector_class);
  260.  
  261.     /* here, need to make things like sequence_class uninstantiable */
  262.  
  263.     make_uninstantiable (collection_class);
  264.     make_uninstantiable (explicit_key_collection_class);
  265.     make_uninstantiable (stretchy_collection_class);
  266.     make_uninstantiable (mutable_collection_class);
  267.     make_uninstantiable (sequence_class);
  268.     make_uninstantiable (mutable_explicit_key_collection_class);
  269.     make_uninstantiable (mutable_sequence_class);
  270.  
  271.     make_uninstantiable (number_class);
  272.     make_uninstantiable (complex_class);
  273.  
  274.     make_uninstantiable (condition_class);
  275.     make_uninstantiable (serious_condition_class);
  276.     make_uninstantiable (warning_class);
  277.     make_uninstantiable (restart_class);
  278.     make_uninstantiable (error_class);
  279. }
  280.  
  281. static Object
  282. class_precedence_list (Object class)
  283. {
  284.     if (SEALEDP (class)) {
  285.     return make_empty_list ();
  286.     } else {
  287.     return CLASSPRECLIST (class);
  288.     }
  289. }
  290.  
  291.  
  292. static int
  293. member_2 (Object obj1, Object obj2, Object obj_list)
  294. {
  295.     while (PAIRP (obj_list)) {
  296.     if (obj1 == CAR (obj_list) || obj2 == CAR (obj_list)) {
  297.         return 1;
  298.     }
  299.     obj_list = CDR (obj_list);
  300.     }
  301.     return 0;
  302. }
  303.  
  304. static Object
  305. make_builtin_class (char *name, Object supers)
  306. {
  307.     Object obj;
  308.  
  309.     obj = allocate_object (sizeof (struct class));
  310.  
  311.     CLASSTYPE (obj) = Class;
  312.     CLASSNAME (obj) = make_symbol (name);
  313.     CLASSPROPS (obj) &= ~CLASSSLOTSUNINIT;
  314.     add_top_level_binding (CLASSNAME (obj), obj, 1);
  315.     return make_class (obj, supers, make_empty_list (), NULL);
  316. }
  317.  
  318. Object
  319. make_class (Object obj,
  320.         Object supers,
  321.         Object slot_descriptors,
  322.         char *debug_name)
  323. {
  324.     Object super_slots;
  325.     Object classwide_slots, tmp_slots, prev_tmp_slots;
  326.     Object this_class_slot_descriptors;
  327.     Object allsuperclasses, super;
  328.     Object tmp, slot;
  329.     Object sg_names;
  330.     Object inherited_slots;
  331.     Object *i_tmp_ptr;
  332.     Object *s_tmp_ptr;
  333.     Object *cl_tmp_ptr;
  334.     Object *es_tmp_ptr;
  335.     Object *co_tmp_ptr;
  336.     Object *vi_tmp_ptr;
  337.     struct binding *bind;
  338.  
  339.     CLASSENV (obj) = the_env;
  340.     CLASSPROPS (obj) |= CLASSINSTANTIABLE;
  341.  
  342.     /* allow a single value for supers, make it into a list 
  343.      */
  344.     if (!LISTP (supers)) {
  345.     CLASSSUPERS (obj) = cons (supers, make_empty_list ());
  346.     } else {
  347.     CLASSSUPERS (obj) = supers;
  348.     }
  349.     CLASSPRECLIST (obj) = compute_class_precedence_list (obj);
  350.  
  351.     /* first find slot descriptors for this class */
  352.  
  353.     CLASSINSLOTDS (obj) = make_empty_list ();
  354.     CLASSSLOTDS (obj) = make_empty_list ();
  355.     CLASSCSLOTDS (obj) = make_empty_list ();
  356.     CLASSESSLOTDS (obj) = make_empty_list ();
  357.     CLASSCONSTSLOTDS (obj) = make_empty_list ();
  358.     CLASSVSLOTDS (obj) = make_empty_list ();
  359.  
  360.     /* Process superclasses.  This includes:
  361.      *  1. add the slots of the superclasses
  362.      *  2. add this class to the subclass list of each superclass
  363.      */
  364.  
  365.     if (!LISTP (supers)) {
  366.     /* only one superclass */
  367.     CLASSSUBS (supers) = cons (obj, CLASSSUBS (supers));
  368.     } else {
  369.     while (PAIRP (supers)) {
  370.         super = CAR (supers);
  371.         CLASSSUBS (super) = cons (obj, CLASSSUBS (super));
  372.         supers = CDR (supers);
  373.     }
  374.     }
  375.  
  376. /*    update_slot_descriptors (class); */
  377.  
  378.     i_tmp_ptr = &CLASSINSLOTDS (obj);
  379.     s_tmp_ptr = &CLASSSLOTDS (obj);
  380.     cl_tmp_ptr = &CLASSCSLOTDS (obj);
  381.     es_tmp_ptr = &CLASSESSLOTDS (obj);
  382.     co_tmp_ptr = &CLASSCONSTSLOTDS (obj);
  383.     vi_tmp_ptr = &CLASSVSLOTDS (obj);
  384.  
  385.     allsuperclasses = list_reverse (CDR (CLASSPRECLIST (obj)));
  386.  
  387.     sg_names = make_empty_list ();
  388.     while (!NULLP (allsuperclasses)) {
  389.     /* check for sealed superclass */
  390.     if (SEALEDP (CAR (allsuperclasses))) {
  391.         error ("Cannot create subclass of sealed class",
  392.            CAR (allsuperclasses), NULL);
  393.     }
  394.     super = CAR (allsuperclasses);
  395.     append_slot_descriptors (CLASSSLOTDS (super), &i_tmp_ptr, &sg_names);
  396.     append_slot_descriptors (CLASSESSLOTDS (super), &es_tmp_ptr,
  397.                  &sg_names);
  398.     append_slot_descriptors (CLASSCONSTSLOTDS (super),
  399.                  &co_tmp_ptr, &sg_names);
  400.     add_slot_descriptor_names (CLASSVSLOTDS (super), &sg_names);
  401.     allsuperclasses = CDR (allsuperclasses);
  402.     }
  403.     CLASSSUBS (obj) = make_empty_list ();
  404.  
  405.     for (tmp = slot_descriptors; PAIRP (tmp); tmp = CDR (tmp)) {
  406.     slot = CAR (tmp);
  407.     if (SLOTDALLOCATION (slot) == instance_symbol) {
  408.         append_one_slot_descriptor (slot, &s_tmp_ptr, &sg_names);
  409.     } else if (SLOTDALLOCATION (slot) == class_symbol) {
  410.         append_one_slot_descriptor (slot, &cl_tmp_ptr, &sg_names);
  411.     } else if (SLOTDALLOCATION (slot) == each_subclass_symbol) {
  412.         append_one_slot_descriptor (slot, &es_tmp_ptr, &sg_names);
  413.     } else if (SLOTDALLOCATION (slot) == constant_symbol) {
  414.         append_one_slot_descriptor (slot, &co_tmp_ptr, &sg_names);
  415.     } else if (SLOTDALLOCATION (slot) == virtual_symbol) {
  416.         append_one_slot_descriptor (slot, &vi_tmp_ptr, &sg_names);
  417.     }
  418.     }
  419.  
  420.     if (!CLASSNAME (obj)) {
  421.     CLASSNAME (obj) = allocate_object (sizeof (struct symbol));
  422.  
  423.     SYMBOLNAME (CLASSNAME (obj)) = debug_name;
  424.     }
  425.     /* initialize class and each-subclass slot objects */
  426.     CLASSCSLOTS (obj) = allocate_object (sizeof (struct instance));
  427.  
  428.     INSTTYPE (CLASSCSLOTS (obj)) = Instance;
  429.     INSTCLASS (CLASSCSLOTS (obj)) = class_slots_class;
  430.  
  431.     /*
  432.      * Note - CLASSCSLOTDS must precede CLASSESSLOTDS for
  433.      * print_class_slot_values (print.c) to work correctly.
  434.      */
  435.     INSTSLOTS (CLASSCSLOTS (obj)) =
  436.     (Object *) (VALUESELS (initialize_slots (append (CLASSCSLOTDS (obj),
  437.                                CLASSESSLOTDS (obj)),
  438.                          make_empty_list ()))[0]);
  439.  
  440.     return (obj);
  441. }
  442.  
  443. static Object
  444. add_slot_descriptor_names (Object sd_list, Object *sg_names_ptr)
  445. {
  446.     Object sd;
  447.  
  448.     while (!EMPTYLISTP (sd_list)) {
  449.     sd = CAR (sd_list);
  450.     if (SLOTDSETTER (sd) != false_object) {
  451.         if (member_2 (SLOTDGETTER (sd), SLOTDSETTER (sd), *sg_names_ptr)) {
  452.         error ("slot getter or setter appears in superclass",
  453.                sd, NULL);
  454.  
  455.         }
  456.     } else {
  457.         if (member (SLOTDGETTER (sd), *sg_names_ptr))
  458.         error ("slot getter appears in superclass", sd, NULL);
  459.     }
  460.     }
  461. }
  462.  
  463. static Object
  464. append_slot_descriptors (Object sd_list, Object **new_sd_list_insert_ptr,
  465.              Object *sg_names_ptr)
  466. {
  467.     Object sg_names;
  468.     Object sd;
  469.  
  470.     while (!EMPTYLISTP (sd_list)) {
  471.     append_one_slot_descriptor (CAR (sd_list),
  472.                     new_sd_list_insert_ptr,
  473.                     sg_names_ptr);
  474.     sd_list = CDR (sd_list);
  475.     }
  476. }
  477.  
  478. /*
  479.  * Given a slot descriptor (sd),
  480.  * a pointer to the tail insertion point in a new slot descriptor list
  481.  *  (new_sd_list_insert_ptr),
  482.  * a pointer to a setter-getter names list (sg_names_ptr),
  483.  *
  484.  * This checks the setter and getter of sd for appearance
  485.  * in the sg_names_ptr list.  If either appears already, that's an error.
  486.  *
  487.  * It inserts the slot descriptor in sd_list into the new slot descriptor
  488.  * list (at the end) and updates the tail insertion point appropriately.
  489.  */
  490.  
  491. static Object
  492. append_one_slot_descriptor (Object sd, Object **new_sd_list_insert_ptr,
  493.                 Object *sg_names_ptr)
  494. {
  495.     if (member_2 (SLOTDGETTER (sd), SLOTDSETTER (sd), *sg_names_ptr)) {
  496.     error ("slot getter or setter appears in superclass",
  497.            sd, NULL);
  498.     }
  499.     *sg_names_ptr = cons (SLOTDGETTER (sd), *sg_names_ptr);
  500.     if (SLOTDSETTER (sd)) {
  501.     *sg_names_ptr = cons (SLOTDSETTER (sd), *sg_names_ptr);
  502.     }
  503.     **new_sd_list_insert_ptr = cons (sd, **new_sd_list_insert_ptr);
  504.     *new_sd_list_insert_ptr = &CDR (**new_sd_list_insert_ptr);
  505. }
  506.  
  507. static Object
  508. make_class_driver (Object args)
  509. {
  510.     Object supers_obj, slots_obj, debug_obj;
  511.     static char *debug_string = NULL;
  512.     Object obj;
  513.  
  514.     supers_obj = object_class;
  515.     slots_obj = make_empty_list ();
  516.     debug_obj = NULL;
  517.  
  518.  
  519.     while (!NULLP (args)) {
  520.     if (FIRST (args) == super_classes_keyword) {
  521.         supers_obj = SECOND (args);
  522.     } else if (FIRST (args) == slots_keyword) {
  523.         slots_obj = slot_descriptor_list (SECOND (args), 0);
  524.     } else if (FIRST (args) == debug_name_keyword) {
  525.         debug_obj = SECOND (args);
  526.     } else {
  527.         error ("make: unsupported keyword for <class> class", FIRST (args), NULL);
  528.     }
  529.     args = CDR (CDR (args));
  530.     }
  531.     if (!debug_obj) {
  532.     warning ("make <class> no debug-name specified", NULL);
  533.     } else if (!SYMBOLP (debug_obj)) {
  534.     error ("make <class> debug-name: must specify a symbol argument",
  535.            NULL);
  536.     } else {
  537.     debug_string = SYMBOLNAME (debug_obj);
  538.     }
  539.     if (NULLP (supers_obj)) {
  540.     supers_obj = object_class;
  541.     }
  542.     obj = allocate_object (sizeof (struct class));
  543.  
  544.     CLASSTYPE (obj) = Class;
  545.     CLASSNAME (obj) = NULL;
  546.     CLASSPROPS (obj) |= CLASSSLOTSUNINIT;
  547.     return make_class (obj, supers_obj, slots_obj, debug_string);
  548. }
  549.  
  550. /*
  551.  * initialize_slots (slot_descriptors, initializers)
  552.  *
  553.  * Given
  554.  *  i) a list of slot descriptors for a particular object class, and
  555.  *  ii) a keyword-value association list of initializers
  556.  *
  557.  * Return a 2 element value object with elements
  558.  *  i) a newly initialized vector of bindings representing the appropriately
  559.  *     initialized slots, and
  560.  *  ii) a keyword-value association list of initializers for the object
  561.  *      including pairs for keyword initializable slots with init-values
  562.  *      that were not listed in initializers
  563.  */
  564. Object
  565. initialize_slots (Object slot_descriptors, Object initializers)
  566. {
  567.     int i;
  568.     Object slotd, init_slotds, tmp_slotds;
  569.     Object *slots;
  570.     Object default_initializers, initializer, *def_ptr;
  571.  
  572.  
  573.     /* create defaulted initialization arguments */
  574.  
  575.     /* Create a copy (init_slotds) of the slot descriptors for this object
  576.      * and fill in the init values with the appropriate values as
  577.      * specified by keywords.
  578.      */
  579.  
  580.     /* Note that we reverse the initializers list of keyword-value pairs
  581.      * so they get the right binding if there are duplicates.
  582.      */
  583.     initializers = pair_list_reverse (initializers);
  584.  
  585.     if (PAIRP (initializers)) {
  586.     init_slotds = copy_list (slot_descriptors);
  587.     while (!EMPTYLISTP (initializers)) {
  588.         initializer = CAR (initializers);
  589.         if (KEYWORDP (initializer) && !EMPTYLISTP (CDR (initializers))) {
  590.         replace_slotd_init (init_slotds,
  591.                     initializer,
  592.                     SECOND (initializers));
  593.         } else {
  594.         /* Should check for class or subclass initializer and
  595.          * take appropriate action.  Perhaps memoize the init
  596.          * and perform below.
  597.          */
  598.         error ("Bad slot initializers", initializer, NULL);
  599.         }
  600.         initializers = CDR (CDR (initializers));
  601.     }
  602.     } else {
  603.     init_slotds = copy_list (slot_descriptors);
  604.     }
  605.  
  606.     default_initializers = make_empty_list ();
  607.     def_ptr = &default_initializers;
  608.  
  609.     /*
  610.      * Turn the list of modified slot descriptors (init_slotds)
  611.      * into the corresponding key-value association list (default_initializers)
  612.      * that may be passed to initialize.
  613.      */
  614.     for (tmp_slotds = init_slotds;
  615.      !EMPTYLISTP (tmp_slotds);
  616.      tmp_slotds = CDR (tmp_slotds)) {
  617.     slotd = CAR (tmp_slotds);
  618.     if (SLOTDINITKEYWORD (slotd)) {
  619.         if (SLOTDINIT (slotd) != uninit_slot_object) {
  620.         *def_ptr = listem (SLOTDINITKEYWORD (slotd),
  621.                    SLOTDINIT (slotd),
  622.                    NULL);
  623.         def_ptr = &CDR (CDR (*def_ptr));
  624.         } else if (SLOTDKEYREQ (slotd)) {
  625.         error ("Required keyword not specified",
  626.                SLOTDINITKEYWORD (slotd), NULL);
  627.         }
  628.     }
  629.     }
  630.  
  631.  
  632.     /*
  633.      * Create a vector of slot values (slots)
  634.      * from the list of modified slot descriptors (init_slotds)
  635.      */
  636.     slots = (Object *) checking_malloc (list_length (init_slotds) *
  637.                     sizeof (Object));
  638.  
  639.     tmp_slotds = init_slotds;
  640.     for (i = 0; PAIRP (tmp_slotds); tmp_slotds = CDR (tmp_slotds), i++) {
  641.     slotd = CAR (tmp_slotds);
  642.     slots[i] = listem (slot_init_value (slotd),
  643.                SLOTDSLOTTYPE (slotd),
  644.                NULL);
  645.     }
  646.     return construct_values (2, slots, default_initializers);
  647. }
  648.  
  649. static void
  650. replace_slotd_init (Object init_slotds, Object keyword, Object init)
  651. {
  652.     Object slotd;
  653.     Object new_slotd;
  654.  
  655.     while (PAIRP (init_slotds)) {
  656.     slotd = CAR (init_slotds);
  657.  
  658.     if (SLOTDINITKEYWORD (slotd) == keyword) {
  659.         new_slotd = allocate_object (sizeof (struct slot_descriptor));
  660.  
  661.         CAR (init_slotds) = new_slotd;
  662.         SLOTDPROPS (new_slotd) = SLOTDPROPS (slotd)
  663.         & ~SLOTDINITFUNCTIONMASK;
  664.         SLOTDGETTER (new_slotd) = SLOTDGETTER (slotd);
  665.         SLOTDSETTER (new_slotd) = SLOTDSETTER (slotd);
  666.         SLOTDSLOTTYPE (new_slotd) = SLOTDSLOTTYPE (slotd);
  667.         SLOTDINITKEYWORD (new_slotd) = SLOTDINITKEYWORD (slotd);
  668.         SLOTDALLOCATION (new_slotd) = SLOTDALLOCATION (slotd);
  669.         SLOTDDYNAMISM (new_slotd) = SLOTDDYNAMISM (slotd);
  670.  
  671.         SLOTDINIT (new_slotd) = init;
  672.         return;
  673.     }
  674.     init_slotds = CDR (init_slotds);
  675.     }
  676. /*
  677.  * If you get to here, the keyword did not match a slot init-keyword
  678.  *
  679.  * It's kind of hard to figure out which keywords are and are not
  680.  * acceptable, so I'm allowing any keyword to be specified right now.
  681.  */
  682.  
  683. }
  684.  
  685. static Object
  686. pair_list_reverse (Object lst)
  687. {
  688.     Object result;
  689.  
  690.     result = make_empty_list ();
  691.     while (PAIRP (lst) && PAIRP (CDR (lst))) {
  692.     result = cons (CAR (lst), cons (SECOND (lst), result));
  693.     lst = CDR (CDR (lst));
  694.     }
  695.     return result;
  696. }
  697.  
  698. /*
  699.  * Largely speculative.  Probably will change all around.
  700.  */
  701. static Object
  702. make_limited_int_type (Object args)
  703. {
  704.     Object obj;
  705.  
  706.     obj = allocate_object (sizeof (struct limited_int_type));
  707.  
  708.     LIMINTTYPE (obj) = LimitedIntType;
  709.     while (!NULLP (args)) {
  710.     if (FIRST (args) == min_keyword) {
  711.         if (LIMINTHASMIN (obj)) {
  712.         error ("Minimum value for limited type specified twice", NULL);
  713.         } else {
  714.         LIMINTMIN (obj) = INTVAL (SECOND (args));
  715.         LIMINTPROPS (obj) |= LIMMINMASK;
  716.         }
  717.     } else if (FIRST (args) == max_keyword) {
  718.         if (LIMINTHASMAX (obj)) {
  719.         error ("Maximum value for limited type specified twice", NULL);
  720.         } else {
  721.         LIMINTMAX (obj) = INTVAL (SECOND (args));
  722.         LIMINTPROPS (obj) |= LIMMAXMASK;
  723.         }
  724.     } else {
  725.         error ("make: unsupported keyword for limited integer type",
  726.            FIRST (args), NULL);
  727.     }
  728.     args = CDR (CDR (args));
  729.     }
  730.  
  731.     return (obj);
  732. }
  733.  
  734. /*
  735.  * Incredibly speculative!
  736.  */
  737. static Object
  738. make_union_type (Object typelist)
  739. {
  740.     Object obj, ptr, qtr, union_types;
  741.  
  742.     obj = allocate_object (sizeof (struct union_type));
  743.  
  744.     UNIONTYPE (obj) = UnionType;
  745.     union_types = make_empty_list ();
  746.  
  747.     for (ptr = typelist; PAIRP (ptr); ptr = CDR (ptr)) {
  748.     if (UNIONP (CAR (ptr))) {
  749.         for (qtr = UNIONLIST (CAR (ptr));
  750.          PAIRP (qtr);
  751.          qtr = CDR (qtr)) {
  752.         union_types = cons (CAR (qtr), union_types);
  753.         }
  754.     } else {
  755.         union_types = cons (CAR (ptr), union_types);
  756.     }
  757.     }
  758.     UNIONLIST (obj) = union_types;
  759.  
  760.     return obj;
  761. }
  762.  
  763. /*
  764.  * make_instance (class, initializers)
  765.  *
  766.  * Destructively modifies second parameter to include default initializations.
  767.  *
  768.  */
  769. Object
  770. make_instance (Object class, Object *initializers)
  771. {
  772.     Object obj, ret;
  773.  
  774.     obj = allocate_object (sizeof (struct instance));
  775.  
  776.     INSTTYPE (obj) = Instance;
  777.     INSTCLASS (obj) = class;
  778.     initialize_slotds (class);
  779.     ret = initialize_slots (append (CLASSINSLOTDS (class), CLASSSLOTDS (class)),
  780.                 *initializers);
  781.     INSTSLOTS (obj) = (Object *) (VALUESELS (ret)[0]);
  782.     *initializers = VALUESELS (ret)[1];
  783.  
  784.     return (obj);
  785. }
  786.  
  787. static void
  788. initialize_slotds (Object class)
  789. {
  790.     struct frame *old_env = the_env;
  791.     Object superclasses, superclass;
  792.  
  793.     if (!CLASSUNINITIALIZED (class))
  794.     return;
  795.  
  796.     /*
  797.      * Check initialization status of superclasses.
  798.      * This may seem odd, but sometimes, a superclass may not have been
  799.      * initialized the first time a subclass object is created.
  800.      * (e.g. it might be abstract)
  801.      */
  802.     for (superclasses = CLASSSUPERS (class);
  803.      PAIRP (superclasses);
  804.      superclasses = CDR (superclasses)) {
  805.     if (CLASSUNINITIALIZED (CAR (superclasses))) {
  806.         initialize_slotds (CAR (superclasses));
  807.     }
  808.     }
  809.  
  810.     the_env = CLASSENV (class);
  811.     eval_slotds (CLASSSLOTDS (class));
  812.     make_getters_setters (class, append (CLASSINSLOTDS (class),
  813.                      CLASSSLOTDS (class)));
  814.  
  815.     eval_slotds (CLASSESSLOTDS (class));
  816.     eval_slotds (CLASSCSLOTDS (class));
  817.     make_getters_setters (class, append (CLASSCSLOTDS (class),
  818.                      CLASSESSLOTDS (class)));
  819.  
  820.     make_getters_setters (class, CLASSCONSTSLOTDS (class));
  821.  
  822.     eval_slotds (CLASSVSLOTDS (class));
  823.     make_getters_setters (class, CLASSVSLOTDS (class));
  824.     CLASSPROPS (class) &= ~CLASSSLOTSUNINIT;
  825.     the_env = old_env;
  826. }
  827.  
  828. static void
  829. eval_slotds (Object slotds)
  830. {
  831.     Object slotd;
  832.  
  833.     while (PAIRP (slotds)) {
  834.     slotd = CAR (slotds);
  835.     SLOTDSLOTTYPE (slotd) = eval (SLOTDSLOTTYPE (slotd));
  836.     if (SLOTDDEFERREDTYPE (slotd)) {
  837.         SLOTDSLOTTYPE (slotd) = apply_method (eval (SLOTDSLOTTYPE (slotd)),
  838.                           make_empty_list (),
  839.                           make_empty_list (),
  840.                           1);
  841.     }
  842.     slotds = CDR (slotds);
  843.     }
  844. }
  845.  
  846. Object
  847. make_singleton (Object val)
  848. {
  849.     Object obj;
  850.  
  851.     obj = allocate_object (sizeof (struct singleton));
  852.  
  853.     SINGLETYPE (obj) = Singleton;
  854.     SINGLEVAL (obj) = val;
  855.     return (obj);
  856. }
  857.  
  858. Object
  859. make (Object class, Object rest)
  860. {
  861.     Object slot, slots, type, init_key, val;
  862.     Object init_fun, name, values, ret, initialize_fun;
  863.     struct frame *old_env;
  864.  
  865.     if (!INSTANTIABLE (class)) {
  866.     error ("make: class uninstantiable", class, NULL);
  867.     return false_object;
  868.     }
  869.     /* special case the builtin classes */
  870.     if (class == pair_class) {
  871.     ret = make_pair_driver (rest);
  872.     } else if (class == empty_list_class) {
  873.     ret = make_empty_list ();
  874.     } else if (class == list_class) {
  875.     ret = make_list_driver (rest);
  876.     } else if ((class == vector_class) ||
  877.            (class == simple_object_vector_class)) {
  878.     ret = make_vector_driver (rest);
  879.     } else if ((class == string_class) || (class == byte_string_class)) {
  880.     ret = make_string_driver (rest);
  881.     } else if (class == generic_function_class) {
  882.     ret = make_generic_function_driver (rest);
  883.     } else if ((class == table_class) || (class == object_table_class)) {
  884.     ret = make_table_driver (rest);
  885.     } else if (class == deque_class) {
  886.     ret = make_deque_driver (rest);
  887.     } else if (class == array_class) {
  888.     ret = make_array_driver (rest);
  889.     } else if (class == class_class) {
  890.     ret = make_class_driver (rest);
  891.     } else {
  892.     ret = make_instance (class, &rest);
  893.     }
  894.     initialize_fun = symbol_value (initialize_symbol);
  895.     if (initialize_fun) {
  896.     apply (initialize_fun, cons (ret, rest));
  897.     } else {
  898.     warning ("make: no `initialize' generic function", class, NULL);
  899.     }
  900.     return (ret);
  901. }
  902.  
  903. Object
  904. instance_p (Object obj, Object type)
  905. {
  906.     return (instance (obj, type) ? true_object : false_object);
  907. }
  908.  
  909. int
  910. instance (Object obj, Object type)
  911. {
  912.     Object objtype, supers;
  913.  
  914.     if (SINGLETONP (type)) {
  915.     return id (obj, SINGLEVAL (type));
  916.     } else if (LIMINTP (type)) {
  917.     if (INTEGERP (obj) &&
  918.         ((!LIMINTHASMIN (type)) ||
  919.          INTVAL (obj) >= LIMINTMIN (type)) &&
  920.         ((!LIMINTHASMAX (type)) ||
  921.          INTVAL (obj) <= LIMINTMAX (type))) {
  922.         return 1;
  923.     } else {
  924.         return 0;
  925.     }
  926.     } else if (LIMINTP (obj)) {
  927.     /* not sure on this one.  jnw */
  928.     return subtype (type_class, type);
  929.     } else if (UNIONP (type)) {
  930.     Object ptr;
  931.  
  932.     for (ptr = UNIONLIST (type); PAIRP (ptr); ptr = CDR (ptr)) {
  933.         if (instance (obj, (CAR (ptr)))) {
  934.         return 1;
  935.         }
  936.     }
  937.     return 0;
  938.     }
  939.     objtype = objectclass (obj);
  940.     if (objtype == type) {
  941.     return 1;
  942.     } else {
  943.     return (subtype (objtype, type));
  944.     }
  945. }
  946.  
  947. Object
  948. subtype_p (Object type1, Object type2)
  949. {
  950.     return (subtype (type1, type2) ? true_object : false_object);
  951. }
  952.  
  953. int
  954. subtype (Object type1, Object type2)
  955. {
  956.     Object supers;
  957.  
  958.     if (type1 == type2) {
  959.     return 1;
  960.     } else if (SINGLETONP (type1)) {
  961.     return (instance (SINGLEVAL (type1), type2));
  962.     } else if (LIMINTP (type1)) {
  963.     if (LIMINTP (type2)) {
  964.         if (((!LIMINTHASMIN (type2)) ||
  965.          (LIMINTHASMIN (type1) &&
  966.           (LIMINTMIN (type1) >= LIMINTMIN (type2))))
  967.         &&
  968.         ((!LIMINTHASMAX (type2)) ||
  969.          (LIMINTHASMAX (type1) &&
  970.           (LIMINTMAX (type1) <= LIMINTMAX (type2))))) {
  971.         return 1;
  972.         } else {
  973.         return 0;
  974.         }
  975.     } else {
  976.         return (subtype (integer_class, type2));
  977.     }
  978.     } else if (UNIONP (type1)) {
  979.     Object ptr;
  980.  
  981.     for (ptr = UNIONLIST (type1); PAIRP (ptr); ptr = CDR (ptr)) {
  982.         if (!subtype (CAR (ptr), type2)) {
  983.         return 0;
  984.         }
  985.     }
  986.     return 1;
  987.     } else if (UNIONP (type2)) {
  988.     Object ptr;
  989.  
  990.     for (ptr = UNIONLIST (type2); PAIRP (ptr); ptr = CDR (ptr)) {
  991.         if (subtype (type1, CAR (ptr))) {
  992.         return 1;
  993.         }
  994.     }
  995.     return 0;
  996.     } else {
  997.     supers = CLASSSUPERS (type1);
  998.     if (!supers) {
  999.         return 0;
  1000.     }
  1001.     while (!NULLP (supers)) {
  1002.         if (subtype (CAR (supers), type2)) {
  1003.         return 1;
  1004.         }
  1005.         supers = CDR (supers);
  1006.     }
  1007.     return 0;
  1008.     }
  1009. }
  1010.  
  1011. Object
  1012. direct_superclasses (Object class)
  1013. {
  1014.     if (!SEALEDP (class)) {
  1015.     return CLASSSUPERS (class);
  1016.     } else {
  1017.     return make_empty_list ();
  1018.     }
  1019. }
  1020.  
  1021. Object
  1022. direct_subclasses (Object class)
  1023. {
  1024.     return CLASSSUBS (class);
  1025. }
  1026.  
  1027. Object
  1028. objectclass (Object obj)
  1029. {
  1030.     switch (TYPE (obj)) {
  1031. #ifdef BIG_INTEGERS
  1032.     case Integer:
  1033.     return (small_integer_class);
  1034.     case BigInteger:
  1035.     return (big_integer_class);
  1036. #else
  1037.     case Integer:
  1038.     return (integer_class);
  1039. #endif
  1040.     case True:
  1041.     case False:
  1042.     return (boolean_class);
  1043.     break;
  1044.     case Ratio:
  1045.     return (ratio_class);
  1046.     case SingleFloat:
  1047.     return (single_float_class);
  1048.     case DoubleFloat:
  1049.     return (double_float_class);
  1050.     case EmptyList:
  1051.     return (empty_list_class);
  1052.     case Pair:
  1053.     return (pair_class);
  1054.     case ByteString:
  1055.     return (byte_string_class);
  1056.     case SimpleObjectVector:
  1057.     return (simple_object_vector_class);
  1058.     case ObjectTable:
  1059.     return (object_table_class);
  1060.     case Deque:
  1061.     return (deque_class);
  1062.     case Array:
  1063.     return (array_class);
  1064.     case Condition:
  1065.     return (condition_class);
  1066.     case Symbol:
  1067.     return (symbol_class);
  1068.     case Keyword:
  1069.     return (keyword_class);
  1070.     case Character:
  1071.     return (character_class);
  1072.     case Class:
  1073.     return (class_class);
  1074.     case Instance:
  1075.     return (INSTCLASS (obj));
  1076.  
  1077.     /* need to check the following two cases */
  1078.     case LimitedIntType:
  1079.     return (type_class);
  1080.     case UnionType:
  1081.     return (type_class);
  1082.  
  1083.     case Primitive:
  1084.     return (primitive_class);
  1085.     case GenericFunction:
  1086.     return (generic_function_class);
  1087.     case Method:
  1088.     return (method_class);
  1089.     case Exit:
  1090.     return (exit_function_class);
  1091.     case Unspecified:
  1092.     return (object_class);
  1093.     case EndOfFile:
  1094.     return (object_class);
  1095.     case Stream:
  1096.     return (stream_class);
  1097.     case TableEntry:
  1098.     return (table_entry_class);
  1099.     case DequeEntry:
  1100.     return (deque_entry_class);
  1101.     case Singleton:
  1102.     return (singleton_class);
  1103.     case ForeignPtr:
  1104.     return (foreign_pointer_class);        /* <pcb> */
  1105.     default:
  1106.     error ("object-class: don't know class of object", obj, NULL);
  1107.     }
  1108. }
  1109.  
  1110. Object
  1111. singleton (Object val)
  1112. {
  1113.     return (make_singleton (val));
  1114. }
  1115.  
  1116. Object
  1117. same_class_p (Object class1, Object class2)
  1118. {
  1119.     if (class1 == class2) {
  1120.     return (true_object);
  1121.     } else if ((POINTERTYPE (class1) == Singleton) &&
  1122.            (POINTERTYPE (class2) == Singleton)) {
  1123.     if (id_p (SINGLEVAL (class1), SINGLEVAL (class2), make_empty_list ())
  1124.         == false_object) {
  1125.         return (false_object);
  1126.     } else {
  1127.         return (true_object);
  1128.     }
  1129.     } else {
  1130.     return (false_object);
  1131.     }
  1132. }
  1133.  
  1134. void
  1135. make_getter_setter_gfs (Object slotds)
  1136. {
  1137.     Object getter, setter;
  1138.  
  1139.     while (PAIRP (slotds)) {
  1140.  
  1141.     /* Fix up the getter first */
  1142.  
  1143.     getter = SLOTDGETTER (CAR (slotds));
  1144.     if (SYMBOLP (getter)) {
  1145.         if (NULL == symbol_value (getter)) {
  1146.         SLOTDGETTER (CAR (slotds)) =
  1147.             make_generic_function (getter,
  1148.                        listem (x_symbol,
  1149.                            hash_rest_symbol,
  1150.                            x_symbol,
  1151.                            NULL),
  1152.                        make_empty_list ());
  1153.         add_top_level_binding (getter, SLOTDGETTER (CAR (slotds)), 1);
  1154.         } else if (!GFUNP (symbol_value (getter))) {
  1155.         error ("Getter symbol not bound to a generic function",
  1156.                getter,
  1157.                symbol_value (getter),
  1158.                NULL);
  1159.         } else {
  1160.         SLOTDGETTER (CAR (slotds)) = symbol_value (getter);
  1161.         }
  1162.     } else {
  1163.         /* getter is not a symbol */
  1164.         error ("Getter name is not a symbol", getter, NULL);
  1165.     }
  1166.  
  1167.     /* Now fix up the setter */
  1168.  
  1169.     if (!id (SLOTDALLOCATION (CAR (slotds)), constant_symbol)) {
  1170.         setter = SLOTDSETTER (CAR (slotds));
  1171.         if (NULL == setter) {
  1172.         /* Manufacture the setter name */
  1173.         setter =
  1174.             SLOTDSETTER (CAR (slotds)) =
  1175.             make_setter_symbol (getter);
  1176.         }
  1177.         if (SYMBOLP (setter)) {
  1178.         if (NULL == symbol_value (setter)) {
  1179.             SLOTDSETTER (CAR (slotds)) =
  1180.             make_generic_function (setter,
  1181.                            listem (x_symbol,
  1182.                                x_symbol,
  1183.                                hash_rest_symbol,
  1184.                                x_symbol,
  1185.                                NULL),
  1186.                            make_empty_list ());
  1187.             add_top_level_binding (setter,
  1188.                        SLOTDSETTER (CAR (slotds)),
  1189.                        1);
  1190.         } else if (!GFUNP (symbol_value (setter))) {
  1191.             error ("Setter symbol not bound to a generic function",
  1192.                setter,
  1193.                symbol_value (setter),
  1194.                NULL);
  1195.         } else {
  1196.             SLOTDSETTER (CAR (slotds)) = symbol_value (setter);
  1197.         }
  1198.         } else if (setter == false_object) {
  1199.         SLOTDSETTER (CAR (slotds)) = setter;
  1200.         } else {
  1201.         /* setter is not a symbol */
  1202.         error ("Setter name is not a symbol", setter, NULL);
  1203.         }
  1204.  
  1205.     }
  1206.     slotds = CDR (slotds);
  1207.     }
  1208. }
  1209.  
  1210. static void
  1211. make_getters_setters (Object class, Object slotds)
  1212. {
  1213.     Object slotd, getter, setter;
  1214.     Object getter_name, setter_name;
  1215.     int slot_num = 0;
  1216.  
  1217.     while (!EMPTYLISTP (slotds)) {
  1218.     slotd = CAR (slotds);
  1219.     make_getter_method (slotd, class, slot_num);
  1220.     if (SLOTDALLOCATION (slotd) != constant_symbol) {
  1221.         make_setter_method (slotd, class, slot_num);
  1222.     }
  1223.     slotds = CDR (slotds);
  1224.     slot_num++;
  1225.     }
  1226. }
  1227.  
  1228. /*
  1229.  
  1230.    params = ((obj <class>))
  1231.    body = (slot-value obj 'slot)
  1232.  
  1233.  */
  1234. static Object
  1235. make_getter_method (Object slot, Object class, int slot_num)
  1236. {
  1237.     Object params, body, slot_location, allocation, gf;
  1238.     struct binding *gf_binding;
  1239.     Object class_location;
  1240.  
  1241.     if (!GFUNP (SLOTDGETTER (slot))) {
  1242.     error ("Slot getter is not a generic function",
  1243.            SLOTDGETTER (slot),
  1244.            NULL);
  1245.     }
  1246.     if (CLASSNAME (class)) {
  1247.     class_location = CLASSNAME (class);
  1248.     } else {
  1249.     class_location = listem (quote_symbol, class, NULL);
  1250.     }
  1251.     params = listem (listem (obj_sym, class_location, NULL),
  1252.              NULL);
  1253.  
  1254.     allocation = SLOTDALLOCATION (slot);
  1255.     if (allocation == instance_symbol) {
  1256.     slot_location = obj_sym;
  1257.     } else if (allocation == class_symbol ||
  1258.            allocation == each_subclass_symbol) {
  1259.     slot_location = listem (class_slots_symbol,
  1260.                 listem (quote_symbol, class, NULL),
  1261.                 NULL);
  1262.     } else if (allocation == virtual_symbol) {
  1263.     return SLOTDGETTER (slot);
  1264.     } else if (allocation != constant_symbol) {
  1265.     error ("Bad slot allocation ", allocation, NULL);
  1266.     }
  1267.     if (allocation == constant_symbol) {
  1268.     body = cons (SLOTDINIT (slot), make_empty_list ());
  1269.     } else {
  1270.     body = listem (listem (slot_val_sym,
  1271.                    slot_location,
  1272.                    make_integer (slot_num),
  1273.                    NULL),
  1274.                NULL);
  1275.     }
  1276.     return (make_method (GFNAME (SLOTDGETTER (slot)),
  1277.              params, body, the_env, 1));
  1278. }
  1279.  
  1280. /*
  1281.  
  1282.    params = ((obj <class>) val)
  1283.    body = (set-slot-value! obj 'slot val)
  1284.  
  1285.  */
  1286. static Object
  1287. make_setter_method (Object slot, Object class, int slot_num)
  1288. {
  1289.     Object params, body, slot_location, allocation, gf;
  1290.     struct binding *gf_binding;
  1291.     Object class_location;
  1292.  
  1293.     if (NULL == SLOTDSETTER (slot) || false_object == SLOTDSETTER (slot)) {
  1294.     return NULL;
  1295.     }
  1296.     if (!GFUNP (SLOTDSETTER (slot))) {
  1297.     error ("Slot setter is not a generic function",
  1298.            SLOTDSETTER (slot),
  1299.            NULL);
  1300.     }
  1301.     if (CLASSNAME (class)) {
  1302.     class_location = CLASSNAME (class);
  1303.     } else {
  1304.     class_location = listem (quote_symbol, class, NULL);
  1305.     }
  1306.     params = listem (listem (val_sym,
  1307.                  listem (quote_symbol,
  1308.                      SLOTDSLOTTYPE (slot),
  1309.                      NULL),
  1310.                  NULL),
  1311.              listem (obj_sym, class_location, NULL),
  1312.              NULL);
  1313.     allocation = SLOTDALLOCATION (slot);
  1314.     if (allocation == instance_symbol) {
  1315.     slot_location = obj_sym;
  1316.     } else if (allocation == class_symbol ||
  1317.            allocation == each_subclass_symbol) {
  1318.     slot_location = listem (class_slots_symbol,
  1319.                 listem (quote_symbol, class, NULL),
  1320.                 NULL);
  1321.     } else if (allocation == constant_symbol) {
  1322.     error ("BUG - attempt to allocate setter for constant slot",
  1323.            slot, NULL);
  1324.     } else if (allocation == virtual_symbol) {
  1325.     return SLOTDSETTER (slot);
  1326.     } else {
  1327.     error ("Bad slot allocation ", allocation, NULL);
  1328.     }
  1329.     body = listem (listem (set_slot_value_sym,
  1330.                slot_location,
  1331.                make_integer (slot_num),
  1332.                val_sym,
  1333.                NULL),
  1334.            NULL);
  1335.     return (make_method (GFNAME (SLOTDSETTER (slot)),
  1336.              params, body, the_env, 1));
  1337. }
  1338.  
  1339.  
  1340. Object
  1341. slot_descriptor_list (Object slots, int do_eval)
  1342. {
  1343.     char *name;
  1344.     Object slot;
  1345.     Object getter, setter;
  1346.     Object type, init;
  1347.     Object init_keyword, allocation;
  1348.     Object values;
  1349.     int type_seen, init_seen, allocation_seen, dynamism_seen, getter_seen;
  1350.     unsigned char properties;
  1351.     Object descriptors;
  1352.     Object *desc_ptr;
  1353.     Object slotelt;
  1354.     Object dynamism;
  1355.  
  1356.     descriptors = make_empty_list ();
  1357.     desc_ptr = &descriptors;
  1358.     while (PAIRP (slots)) {
  1359.     slot = CAR (slots);
  1360.  
  1361.     getter = NULL;
  1362.     setter = NULL;
  1363.     type = CLASSNAME (object_class);
  1364.     init = uninit_slot_object;
  1365.     init_keyword = NULL;
  1366.     allocation = instance_symbol;
  1367.     dynamism = open_symbol;
  1368.     type_seen = 0;
  1369.     init_seen = 0;
  1370.     allocation_seen = 0;
  1371.     dynamism_seen = 0;
  1372.     getter_seen = 0;
  1373.     properties = 0;
  1374.  
  1375.     if (SYMBOLP (slot)) {
  1376.         /* simple slot descriptor */
  1377.         getter = slot;
  1378.     } else {
  1379.         if (SYMBOLP (CAR (slot))) {
  1380.         /* first elt is getter name */
  1381.         getter = CAR (slot);
  1382.         slot = CDR (slot);
  1383.         getter_seen = 1;
  1384.         }
  1385.         while (PAIRP (slot)) {
  1386.         slotelt = CAR (slot);
  1387.         /* parse keyword-value pairs for slot initialization */
  1388.         if (!KEYWORDP (slotelt) || EMPTYLISTP (CDR (slot))) {
  1389.             error ("malformed slot descriptor", slot, NULL);
  1390.         } else if (slotelt == getter_keyword) {
  1391.             if (getter_seen) {
  1392.             error ("redundant getter specified", SECOND (slot),
  1393.                    NULL);
  1394.             }
  1395.             getter_seen = 1;
  1396.             getter = SECOND (slot);
  1397.         } else if (slotelt == setter_keyword) {
  1398.             if (setter != NULL) {
  1399.             error ("redundant specification for slot setter name",
  1400.                    SECOND (slot), NULL);
  1401.             }
  1402.             setter = SECOND (slot);
  1403.         } else if (slotelt == allocation_keyword) {
  1404.             if (allocation_seen) {
  1405.             error ("redundant specification for allocation",
  1406.                    SECOND (slot), NULL);
  1407.             }
  1408.             allocation_seen = 1;
  1409.             allocation = SECOND (slot);
  1410.         } else if (slotelt == type_keyword) {
  1411.             if (type_seen) {
  1412.             error ("redundant specification for type",
  1413.                    SECOND (slot), NULL);
  1414.             }
  1415.             type_seen = 1;
  1416.             /*
  1417.              * type_keyword indicates eval this slot!
  1418.              */
  1419.             type = SECOND (slot);
  1420.         } else if (slotelt == deferred_type_keyword) {
  1421.             if (type_seen) {
  1422.             error ("redundant specification for type",
  1423.                    SECOND (slot), NULL);
  1424.             }
  1425.             type_seen = 1;
  1426.             type = SECOND (slot);
  1427.             properties |= SLOTDDEFERREDTYPEMASK;
  1428.         } else if (slotelt == init_value_keyword) {
  1429.             if (init_seen) {
  1430.             error ("redundant specification for initializer",
  1431.                    SECOND (slot), NULL);
  1432.             }
  1433.             init_seen = 1;
  1434.             init = SECOND (slot);
  1435.         } else if (slotelt == init_function_keyword) {
  1436.             if (init_seen) {
  1437.             error ("redundant specification for initializer",
  1438.                    SECOND (slot), NULL);
  1439.             }
  1440.             init_seen = 1;
  1441.             init = do_eval ? eval (SECOND (slot)) : SECOND (slot);
  1442.             properties |= SLOTDINITFUNCTIONMASK;
  1443.         } else if (slotelt == init_keyword_keyword) {
  1444.             if (init_keyword) {
  1445.             error ("redundant init-keyword: specification",
  1446.                    SECOND (slot), NULL);
  1447.             }
  1448.             init_keyword = SECOND (slot);
  1449.             if (!KEYWORDP (init_keyword)) {
  1450.             error ("init-keyword: value is not a keyword",
  1451.                    init_keyword, NULL);
  1452.             }
  1453.         } else if (slotelt == required_init_keyword_keyword) {
  1454.             if (init_keyword) {
  1455.             error ("redundant required-init-keyword: specification",
  1456.                    SECOND (slot), NULL);
  1457.             }
  1458.             init_keyword = SECOND (slot);
  1459.             if (!KEYWORDP (init_keyword)) {
  1460.             error ("required-init-keyword: value is not a keyword",
  1461.                    init_keyword, NULL);
  1462.             }
  1463.             properties |= SLOTDKEYREQMASK;
  1464.         } else if (slotelt == dynamism_keyword) {
  1465.             if (dynamism_seen) {
  1466.             error ("Dynamism of slot specified twice",
  1467.                    SECOND (slot), NULL);
  1468.             }
  1469.             dynamism = SECOND (slot);
  1470.         } else {
  1471.             error ("unknown slot keyword initializer", slotelt, NULL);
  1472.         }
  1473.         slot = CDR (CDR (slot));
  1474.         }
  1475.     }
  1476.     if (!getter) {
  1477.         error ("Slot has no getter", CAR (slots), NULL);
  1478.     }
  1479.     if (allocation == constant_symbol) {
  1480.         if (init == NULL || properties & SLOTDINITFUNCTIONMASK) {
  1481.         error ("Bad initialization for constant slot",
  1482.                CAR (slots), NULL);
  1483.         }
  1484.     }
  1485.     if (properties & SLOTDKEYREQMASK) {
  1486.         if (init != uninit_slot_object) {
  1487.         error ("required-init-keyword should not have initial value",
  1488.                CAR (slots), NULL);
  1489.         }
  1490.     }
  1491.     *desc_ptr =
  1492.         cons (make_slot_descriptor (properties, getter, setter, type,
  1493.                     init, init_keyword, allocation,
  1494.                     dynamism),
  1495.           make_empty_list ());
  1496.     desc_ptr = &CDR (*desc_ptr);
  1497.  
  1498.     slots = CDR (slots);
  1499.     }
  1500.     return descriptors;
  1501. }
  1502.  
  1503. Object
  1504. seal (Object class)
  1505. {
  1506.     CLASSPROPS (class) |= CLASSSEAL;
  1507.     return class;
  1508. }
  1509.  
  1510. void
  1511. make_uninstantiable (Object class)
  1512. {
  1513.     CLASSPROPS (class) &= ~CLASSINSTANTIABLE;
  1514. }
  1515.  
  1516. void
  1517. make_primary (Object class)
  1518. {
  1519.     /* Need to add some semantics here.  Requires field in class object rep. */
  1520. }
  1521.